Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/gamesrc/fring11/pic_make.pas

Pascal/Delphi Source File | 1992-12-17 | 10KB | 438 lines

{
***************************************************************************
* PIC_MAKER - for                                                         *
* FRINGDUS - The Game. (1/12/92)                                          *
*                                                                         *
*  By Jason Nunn (JsNO BAR----NUNN)                                       *
*                                                                         *
*  Email: [e-mail]                                     *
*                                                                         *
*  This code is freeware.                                                 *
*                                                                         *
* Description: Allows you to make 30*30 256 colour sprites.               *
*                                                                         *
***************************************************************************
}
program pic_maker;

uses
  crt;

const
  norm_vid  = 3;
  hires_vid = 19;
  video_mem = 40960;

  nullchar               = #0;
  enter                  = #13;
  back_space             = #8;
  bell                   = #7;
  uparrow                = #0#72;
  leftarrow              = #0#75;
  rightarrow             = #0#77;
  downarrow              = #0#80;
  esc                    = #27;
  space                  = ' ';


type
  pic_attrib = record
                 colour : byte;
               end;
  pic_file_attrib = file of pic_attrib;

var
  pic_file  : pic_file_attrib;
  pic       : pic_attrib;
  ch        : string[2];
  cx        : integer;
  cy        : integer;
  cxl       : integer;
  cyl       : integer;
  p_colour  : word;

{
***************************************************************************
*                                                                         *
* Utility functions                                                       *
*                                                                         *
***************************************************************************
}


procedure videooff; assembler;
asm
  mov  al,norm_vid  {normal default value}
  mov  ah,0
  int  16 {Video services interrupt, for more}
end;      {information, have a look at your system manuals}

{I couldn't get my graphic libraries to work, to put it in Hires, so
I made the routines myself}


procedure videoon; assembler;
asm
  mov  al,hires_vid  {320*200   256 colour mode}
  mov  ah,0
  int  16
end;




{Puts a byte on to the video memory at location X,Y, the byte value is
the COLOUR}

procedure write_byte(colour : byte; ggx, ggy : word); assembler;
asm
  mov   bx,video_mem
  mov   es,bx

  mov   ax,ggy
  mov   bx,320
  mul   bx

  add   ax,ggx
  mov   bx,ax
  mov   al,colour
  mov   es:[bx],al
end;



{Here we read a byte value at position X,Y}

function get_colour(ggx, ggy : word) : byte; assembler;
asm
  mov   bx,video_mem
  mov   es,bx

  mov   ax,ggy
  mov   bx,320
  mul   bx

  add   ax,ggx
  mov   bx,ax

  mov   al, es:[bx]  {AL is returned, hence: get_colour := AL}
end;




{sets 8x6 block of bytes in video memory a certain value(colour) }

procedure write_6_8_block(colour : byte; x, y : word); assembler;
var
  store_y : word;

asm
  mov   bx,video_mem
  mov   es,bx
  mov   ax,0
  mov   store_y, ax
  dec   y
@@bloc_loop:
  add   y,1
  mov   ax,y
  mov   bx,320
  mul   bx

  add   ax, x
  mov   di, ax
  mov   al, colour
  mov   cx, 7
  cld
  rep   stosb

  inc   store_y
  cmp   store_y,5
  jne   @@bloc_loop
end;


{This is a highlight bar that is intended for the block colours, on
the screen in determining that current colour that the user has selected}

procedure hl_6_8_block(colour : byte; x, y : word); assembler;
asm
  mov   bx,video_mem
  mov   es,bx

  mov   ax,y
  mov   bx,320
  mul   bx

  add   ax, x
  mov   di, ax
  mov   al, colour
  mov   cx, 7
  cld
  rep   stosb
end;

{sets 3x3 block of bytes in video memory a certain value(colour) }

procedure write_3_3_block(colour : byte; x, y : word); assembler;
var
  store_y : word;

asm
  mov   bx,video_mem
  mov   es,bx
  mov   ax,0
  mov   store_y, ax
  dec   y
@@bloc_loop:
  add   y,1
  mov   ax,y
  mov   bx,320
  mul   bx

  add   ax, x
  mov   di, ax
  mov   al, colour
  mov   cx, 3
  cld
  rep   stosb

  inc   store_y
  cmp   store_y,3
  jne   @@bloc_loop
end;



{This routine clears the screen}

procedure clr(color : byte); assembler;
asm
  mov   bx,video_mem
  mov   es,bx
  mov   al,color
  mov   di, 0
  mov   si, di
  mov   cx,64000

  cld
  rep   stosb
end;

{
***************************************************************************
*                                                                         *
***************************************************************************
}
procedure base_screen;
var
  x      : word;
  y      : word;
  colour : word;
begin
  colour := 0;
  for y := 0 to 7 do
  begin
    for x := 0 to 38 do
    begin
      if colour <= 255 then
      begin
        write_6_8_block(colour, x * 8, y * 6); {writes the blocks of colour}
      end;

      if (p_colour = (x + (y * 39))) then
      begin
        hl_6_8_block(15, x * 8, (y * 6) + 5);
      end;
      colour := colour + 1;
    end;
  end;
  for x := 218 to 311 do
    write_byte(15, x, 98);

  for x := 98 to 191 do
    write_byte(15, 218, x);   {writes the pretty border, for sprite editing area}

  for x := 218 to 311 do
    write_byte(15, x, 191);

  for x := 98 to 191 do
    write_byte(15, 311, x);

  for x := 0 to 33 do
  begin
    write_byte(15, x + 48, 98); {writes another pretty border, (for the sprite area)}
    write_byte(15, 48, 98 + x);
    write_byte(15, 81, 131 - x);
    write_byte(15, 81 - x, 131);
  end;
end;

{
***************************************************************************
*                                                                         *
* The code is obvious                                                     *
*                                                                         *
***************************************************************************
}
procedure paint_pic;
var
  x      : word;
  y      : word;
begin
  base_screen;
  cx := 0;
  cy := 0;
  cxl := 0;
  cyl := 0;
  ch := #0;
  repeat

    if ch = downarrow then
      cy := cy + 1
    else if ch = uparrow then
      cy := cy - 1
    else if ch = leftarrow then
      cx := cx - 1
    else if ch = rightarrow then
      cx := cx + 1
    else if (ch = '+') or (ch = '-') or (ch = '/') or (ch = '*') then
    begin
      for y := 0 to 7 do
      begin
        for x := 0 to 38 do
        begin
          if (p_colour = (x + (y * 39))) then
          begin
            hl_6_8_block(0, x * 8, (y * 6) + 5);
          end;
        end;
      end;

      if ch = '+' then
        p_colour := p_colour + 1
      else if ch = '-' then
        p_colour := p_colour - 1
      else if ch = '/' then
        p_colour := p_colour - 10
      else if ch = '*' then
        p_colour := p_colour + 10;

      if p_colour < 0 then p_colour := 0;
      if p_colour > 255 then p_colour := 255;

      for y := 0 to 7 do
      begin
        for x := 0 to 38 do
        begin
          if (p_colour = (x + (y * 39))) then
          begin
            hl_6_8_block(15, x * 8, (y * 6) + 5);
          end;
        end;
      end;
    end
    else if ch = '`' then
    begin
      for y := 0 to 29 do
        for x := 0 to 29 do
        begin
          write_byte(p_colour, x + 50, y + 100);
          write_3_3_block(p_colour, 220 + (x * 3), 100 + (y * 3));
        end;
      cxl := cx;
      cyl := cy;
    end;

    if ch = 's' then
    begin
      rewrite(pic_file);
      for cy := 0 to 29 do
        for cx := 0 to 29 do
        begin
          pic.colour := get_colour(cx + 50, cy + 100);
          write(pic_file, pic);
        end;
    end;
    if ch = 'f' then
    begin
      rewrite(pic_file);
      for cy := 29 downto 0 do
        for cx := 0 to 29 do
        begin
          pic.colour := get_colour(cx + 50, cy + 100);
          write(pic_file, pic);
        end;
    end;
    if ch = 't' then
    begin
      rewrite(pic_file);
      for cy := 0 to 29 do
        for cx := 29 downto 0 do
        begin
          pic.colour := get_colour(cx + 50, cy + 100);
          write(pic_file, pic);
        end;
    end;

    if cx < 0 then cx := 0;
    if cx > 29 then cx := 29;
    if cy < 0 then cy := 0;
    if cy > 29 then cy := 29;

    write_3_3_block(get_colour(cxl + 50, cyl + 100), 220 + (cxl * 3), 100 + (cyl * 3));
    write_3_3_block(p_colour, 220 + (cx * 3), 100 + (cy * 3));
    if ch = space then
    begin
      write_byte(p_colour, cx + 50, cy + 100);
    end;

    cxl := cx;
    cyl := cy;

    ch := readkey;
    if ch = #0 then ch := ch + readkey;
  until ch = #27;
end;

{
***************************************************************************
*                                                                         *
* The code is obvious                                                     *
*                                                                         *
***************************************************************************
}
begin
  if (paramstr(1) <> '') and (paramstr(1) <> '-h') then
  begin
    p_colour := 1;
    videoon;
    clr(0);
    assign(pic_file,paramstr(1));
    {$I-}
    reset(pic_file);
    {$I-}
    if ioresult = 0 then
    begin
      for cy := 0 to 29 do
        for cx := 0 to 29 do
        begin
          read(pic_file, pic);
          write_byte(pic.colour, cx + 50, cy + 100);
          write_3_3_block(pic.colour, 220 + (cx * 3), 100 + (cy * 3));
        end;
    end;
    paint_pic;
    close(pic_file);
    videooff;
  end
  else
  begin
    writeln;   {logo.......hey ya!, hey ya!, hey ya!}
    writeln('MAP_MAK2 - By Jason Nunn - (C) 1992 - This Game is Freeware');
    writeln;
    writeln('Instructions: Read Manual (readme.txt)');
    writeln;
  end;
end.